home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
XMSLIBR1.ARJ
/
XMSLIB.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-08-11
|
21KB
|
580 lines
(******************************************************************************
* xmsLib *
******************************************************************************)
unit xmsLib;
interface
uses
dos
;
type
xmsMovePtr = ^xmsMoveStructure;
xmsMoveStructure = record
length : longint; { 32-bit # of bytes to transfer }
sourceHandle : word;
sourceOffset : longint;
destHandle : word;
destOffset : longint;
end; { xmsMoveStructure definition }
var
xmsPresent : boolean; { true if XMS was detected }
xmsAddress : pointer; { used to point to XMS entry address }
xmsVersion : word;
xmmVersion : word;
hmaPresent : boolean;
xmsErrorCode : byte; { if an error exists, it will be placed here }
procedure detectXMS; { look for xms existance, and sets global library variables }
procedure setXMSHandlerAddress;
procedure getXMSVersionNumber;
function printXMSVersion : string; { a readable string .. }
function printXMMVersion : string; { a readable string .. }
function requestHMA : boolean;
function releaseHMA : boolean;
function globalEnableA20 : boolean;
function globalDisableA20 : boolean;
function localEnableA20 : boolean;
function localDisableA20 : boolean;
function queryA20 : boolean;
procedure queryFreeExtendedMemory(var largestBlock, totalInK : word);
function xmsLargestBlock : word;
function xmsTotalFreeMemory : word;
function allocateXMB(sizeInK : word; var handle : word) : boolean;
function freeXMB(handle : word) : boolean;
function moveXMB(structure : xmsMovePtr) : boolean;
function moveXMBlock(len : longint; srcHandle : word; srcOfs : longint;
dstHandle : word; dstOfs : longint) : boolean;
function mainstgToXMB(len : word; fromPtr : pointer;
toHandle : word; toOfs : longint) : boolean;
function XMBtoMainstg(len : word; toPtr : pointer;
fmHandle : word; fmOfs : longint) : boolean;
function lockXMB(handle : word) : boolean;
function unlockXMB(handle : word) : boolean;
function getXMBInformation(handle : word; var lockCount, freeHandles : byte;
var sizeInK : word) : boolean;
function reallocXMB(newSizeInK, handle : word) : boolean;
function requestUMB(sizeInParagraphs : word; var segmentOfUMB : word;
var sizeAllocatedOrAvailable : word) : boolean;
function releaseUMB(segmentOfUMB : word) : boolean;
function xmsErrorStr : string;
implementation
type
xmsErrorType = record
errorNumber : byte;
errorMessage : string;
end;
const
maxXMSErrors = 27;
xmsErrorArray : array [1 .. maxXMSErrors] of xmsErrorType = (
(errorNumber : $80; errorMessage : 'Function not implemented'),
(errorNumber : $81; errorMessage : 'VDISK device detected'),
(errorNumber : $82; errorMessage : 'A20 Error occured'),
(errorNumber : $8e; errorMessage : 'General driver error'),
(errorNumber : $8f; errorMessage : 'Fatal driver error'),
(errorNumber : $90; errorMessage : 'HMA does not exist'),
(errorNumber : $91; errorMessage : 'HMA is already in use'),
(errorNumber : $92; errorMessage : 'Size is smaller then /HMAMIN= parameter'),
(errorNumber : $93; errorMessage : 'HMA not allocated'),
(errorNumber : $94; errorMessage : 'A20 line still enabled'),
(errorNumber : $a0; errorMessage : 'No more free extended memory'),
(errorNumber : $a1; errorMessage : 'No more XMS handles'),
(errorNumber : $a2; errorMessage : 'Invalid handle'),
(errorNumber : $a3; errorMessage : 'Invalid source handle'),
(errorNumber : $a4; errorMessage : 'Invalid source offset'),
(errorNumber : $a5; errorMessage : 'Invalid destination handle'),
(errorNumber : $a6; errorMessage : 'Invalid destination offset'),
(errorNumber : $a7; errorMessage : 'Invalid length'),
(errorNumber : $a8; errorMessage : 'Move resulted in overlap'),
(errorNumber : $a9; errorMessage : 'Parity error'),
(errorNumber : $aa; errorMessage : 'Block not locked'),
(errorNumber : $ab; errorMessage : 'Block locked'),
(errorNumber : $ac; errorMessage : 'Block lock count overflow'),
(errorNumber : $ad; errorMessage : 'Lock failure'),
(errorNumber : $b0; errorMessage : 'Smaller UMB available'),
(errorNumber : $b1; errorMessage : 'No UMBs available'),
(errorNumber : $b2; errorMessage : 'Invalid UMB segment number')
);
var
regs : registers;
(******************************************************************************
* detectXMS *
******************************************************************************)
procedure detectXMS;
begin
asm
mov xmsPresent, 0 { no xms available }
mov ax, $4300
int $2f { multiplexer interrupt identification }
cmp al, $80 { well , is there XMM ? }
jne @noXMSDriver
mov xmsPresent, 1 { true, we have an xms driver }
@noXMSDriver:
end; { asm }
end; {detectXMS}
(******************************************************************************
* setXMSHandlerAddress *
******************************************************************************)
procedure setXMSHandlerAddress;
begin
asm
mov ax,$4310
int $2f { ES:BX points to xms driver entry point }
mov word ptr [xmsAddress], bx
mov word ptr [xmsAddress + 2], es
end; { asm }
end; {setXMSHandlerAddress}
(******************************************************************************
* getXMSVersionNumber *
******************************************************************************)
procedure getXMSVersionNumber;
begin
asm
xor ah, ah; { function 0 .. }
call [xmsAddress]
mov xmsVersion, ax
mov xmmVersion, bx
mov byte ptr hmaPresent, dl { true or false .. }
end; { asm }
end; {getXMSVersionNumber}
(******************************************************************************
* printXMSVersion *
******************************************************************************)
function printXMSVersion;
var
s1, s2 : string;
begin
str(xmsVersion div $100, s1);
str(xmsVersion mod $100, s2);
printXMSVersion := s1 + '.' + s2;
end; {printXMSVersion}
(******************************************************************************
* printXMMVersion *
******************************************************************************)
function printXMMVersion;
var
s1, s2, s3 : string;
begin
str(XMMVersion div $100, s1);
str((XMMVersion mod $100) div $10, s2);
str(XMMVersion mod $10, s3);
printXMMVersion := s1 + '.'+ s2 + s3;
end; {printXMMVersion}
(******************************************************************************
* requestHMA *
******************************************************************************)
function requestHMA;
var
requestGranted : boolean;
begin
asm
mov ah, 1
mov dx, $ffff { assume we are not tsr, but an application }
call [xmsAddress]
mov requestGranted, al
mov xmsErrorCode, bl
end; { asm }
requestHMA := requestGranted; { if not, check xmsErrorCode }
end; {requestHMA}
(******************************************************************************
* releaseHMA *
******************************************************************************)
function releaseHMA;
var
releaseGranted : boolean;
begin
asm
mov ah, 2
call [xmsAddress]
mov releaseGranted, al
mov xmsErrorCode, bl
end; {asm}
releaseHMA := releaseGranted;
end; {releaseHMA}
(******************************************************************************
* globalEnableA20 *
******************************************************************************)
function globalEnableA20;
var
A20geGranted : boolean;
begin
asm
mov ah, 3
call [xmsAddress]
mov A20geGranted, al
mov xmsErrorCode, bl
end; { asm }
globalEnableA20 := a20geGranted;
end; {globalEnableA20}
(******************************************************************************
* globalDisableA20 *
******************************************************************************)
function globalDisableA20;
var
A20gdGranted : boolean;
begin
asm
mov ah, 4
call [xmsAddress]
mov A20gdGranted, al
mov xmsErrorCode, bl
end; { asm }
globalDisableA20 := a20gdGranted;
end; {globalDisableA20}
(******************************************************************************
* localEnableA20 *
******************************************************************************)
function localEnableA20;
var
A20geGranted : boolean;
begin
asm
mov ah, 5
call [xmsAddress]
mov A20geGranted, al
mov xmsErrorCode, bl
end; { asm }
localEnableA20 := a20geGranted;
end; {localEnableA20}
(******************************************************************************
* localDisableA20 *
******************************************************************************)
function localDisableA20;
var
A20gdGranted : boolean;
begin
asm
mov ah, 6
call [xmsAddress]
mov A20gdGranted, al
mov xmsErrorCode, bl
end; { asm }
localDisableA20 := a20gdGranted;
end; {localDisableA20}
(******************************************************************************
* queryA20 *
* Returns True if A20 is physically enabled. query validity of respons by *
* looking at the xmsErrorCode first ! *
* i.e. ... *
* findA20State := queryA20; *
* if (xmsErrorCode <> 0) then *
* Error *
* else findA20State has the proper value according to the A20 state *
******************************************************************************)
function queryA20;
var
A20State : boolean;
begin
asm
mov ah, 7
call [xmsAddress]
mov A20State, al
mov xmsErrorCode, bl
end; { asm }
queryA20 := A20State;
end; {queryA20}
(******************************************************************************
* queryFreeExtendedMemory *
******************************************************************************)
procedure queryFreeExtendedMemory;
var
ourLB, ourTIK : word;
begin
asm
mov ah, 8
call [xmsAddress]
mov ourLB, ax
mov ourTIK, dx
mov xmsErrorCode, bl
end; { asm }
largestBlock := ourLB;
totalInK := ourTIK;
end; {queryFreeExtendedMemory}
(******************************************************************************
* xmsLargestBlock *
******************************************************************************)
function xmsLargestBlock;
var
lb, tik : word;
begin
queryFreeExtendedMemory(lb, tik);
xmsLargestBlock := lb;
end; {xmsLargestBlock}
(******************************************************************************
* xmsTotalFreeMemory *
******************************************************************************)
function xmsTotalFreeMemory;
var
lb, tik : word;
begin
queryFreeExtendedMemory(lb, tik);
xmsTotalFreeMemory := tik;
end; {xmsTotalFreeMemory}
(******************************************************************************
* allocateXMB *
* if returns True handle has the handle to the memory block *
******************************************************************************)
function allocateXMB;
var
allocGranted : boolean;
ourHandle : word;
begin
asm
mov ah, 9
mov dx, sizeInK
call [xmsAddress]
mov allocGranted, al { did we make it ? }
mov ourHandle, dx
mov xmsErrorCode, bl
end; { asm }
allocateXMB := allocGranted;
if (allocGranted) then
handle := ourHandle;
end; {allocateXMB}
(******************************************************************************
* freeXMB *
******************************************************************************)
function freeXMB;
var
releaseGranted : boolean;
begin
asm
mov ah, $a
mov dx, handle
call [xmsAddress]
mov releaseGranted, al
mov xmsErrorCode, bl
end; { asm }
freeXMB := releaseGranted;
end; {freeXMB}
(******************************************************************************
* moveXMB *
******************************************************************************)
function moveXMB;
var
moveGranted : boolean;
segmento : word;
offseto : word;
begin
segmento := seg(structure^);
offseto := ofs(structure^);
asm
push ds
pop es
mov si, offseto
mov ax, segmento
mov ds, ax
mov ah, $b
call [es:xmsAddress]
push es
pop ds
mov moveGranted, al
mov xmsErrorCode, bl
end; { asm }
moveXMB := moveGranted;
end; {moveXMB}
(******************************************************************************
* moveXMBlock *
******************************************************************************)
function moveXMBlock;
var
struct : xmsMoveStructure;
begin
with struct do begin
length := len;
sourceHandle := srcHandle;
sourceOffset := srcOfs;
destHandle := dstHandle;
destOffset := dstOfs;
end; { with }
moveXMBlock := moveXMB(@struct); { go do it ! }
end; {moveXMBlock}
(******************************************************************************
* mainstgToXMB *
* move fm ptr len bytes to XMB handle, at offset *
******************************************************************************)
function mainstgToXMB;
var
l : longint;
begin
l := longint(fromPtr);
mainstgToXMB := moveXMBlock(len, 0, l, toHandle, toOfs);
end; {mainstgToXMB}
(******************************************************************************
* XMBtoMainstg *
* xmb fmhandle at ofsset fmofs, move to main storage at pointer toptr, len byt*
******************************************************************************)
function XMBtoMainstg;
var
l : longint;
begin
l := longint(toPtr);
XMBtoMainstg := moveXMBlock(len, fmHandle, fmOfs, 0, l);
end; {XMBtoMainstg}
(******************************************************************************
* lockXMB *
******************************************************************************)
function lockXMB;
var
lockGranted : boolean;
begin
asm
mov ah, $c
mov dx, handle
call [xmsAddress]
mov lockGranted, al
mov xmsErrorCode, bl
end; { asm }
lockXMB := lockGranted;
end; {lockXMB}
(******************************************************************************
* unlockXMB *
******************************************************************************)
function unlockXMB;
var
unlockGranted : boolean;
begin
asm
mov ah, $d
mov dx, handle
call [xmsAddress]
mov unlockGranted, al
mov xmsErrorCode, bl
end; { asm }
unlockXMB := unlockGranted;
end; {unlockXMB}
(******************************************************************************
* getXMBInformation *
******************************************************************************)
function getXMBInformation;
var
informationReceived : boolean;
ourSIK : word;
ourFH, ourLC : byte;
begin
asm
mov ah, $e
mov dx, handle
call [xmsAddress]
mov informationReceived, al
mov ourLC, bh
mov ourFH, bl
mov ourSIK, dx
mov xmsErrorCode, bl
end; { asm }
getXMBInformation := informationReceived;
sizeInK := ourSIK;
freeHandles := ourFH;
lockCount := ourLC;
end; {getXMBInformation}
(******************************************************************************
* reallocXMB *
******************************************************************************)
function reallocXMB;
var
reallocGranted : boolean;
begin
asm
mov ah, $f
mov bx, newSizeInK
mov dx, handle
call [xmsAddress]
mov reallocGranted, al
mov xmsErrorCode, bl
end; { asm }
reallocXMB := reallocGranted;
end; {reallocXMB}
(******************************************************************************
* requestUMB *
******************************************************************************)
function requestUMB;
var
requestGranted : boolean;
ourSOUMB, ourSAOA : word;
begin
asm
mov ah, $10
mov dx, sizeInParagraphs
call [xmsAddress]
mov requestGranted, al
mov ourSOUMB, bx
mov ourSAOA, dx
mov xmsErrorCode, bl
end; { asm }
requestUMB := requestGranted;
segmentOfUMB := ourSOUMB;
sizeAllocatedOrAvailable := ourSAOA;
end; {requestUMB}
(******************************************************************************
* releaseUMB *
******************************************************************************)
function releaseUMB;
var
releaseGranted : boolean;
begin
asm
mov ah, $11
mov dx, segmentOfUMB
call [xmsAddress]
mov releaseGranted, al
mov xmsErrorCode, bl
end; { asm }
releaseUMB := releaseGranted;
end; {releaseUMB}
(******************************************************************************
* xmsErrorStr *
******************************************************************************)
function xmsErrorStr;
var
i, errorFound : byte;
begin
errorFound := 0;
for i := 1 to maxXMSErrors do
if (xmsErrorCode = xmsErrorArray[i].errorNumber) then
errorFound := i;
if (errorFound = 0) then
xmsErrorStr := 'Unknown XMS error'
else
xmsErrorStr := xmsErrorArray[errorFound].errorMessage;
end; {xmsErrorStr}
(******************************************************************************
* MAIN *
******************************************************************************)
begin
detectXMS;
if (xmsPresent) then begin
setXMSHandlerAddress;
getXMSVersionNumber;
end;
end.
